;;; emacspeak-firemacs.el --- 

;; Copyright 2006 Lukas Loehrer
;;
;; Author: loehrerl [at] gmx [dot] net
;; Version: $Id: emacspeak-firemacs.el,v 0.0 2006/11/06 10:13:52 luke Exp $
;; Keywords: 
;; X-URL: not distributed yet

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;; 

;; Put this file into your load-path and the following into your ~/.emacs:
;;   (require 'emacspeak-firemacs)

;;; Code:

(provide 'emacspeak-firemacs)
(eval-when-compile
  (require 'cl))

(require 'emacspeak-preamble)
(require 'firemacs)
(require 'firemacs-buffer)

;;{{{Cleanup patterns for non-ASCII characters

(defvar emacspeak-fm-cleanup-nonascii-characters t
  "*Whether to cleanup the buffer content of some nonascii characters after rendering.")

(defcustom emacspeak-fm-cleanup-alist
  '(("\x539a6" . "...") ("\x539a2" . "*") ("\x53978" . "'") ("\x8a0" . " ") ("\x53ae2" . "TM") ("\x53979" . "'") ("\x5397d" . "\"") ("\x5397c" . "\"") ("\x53974" . "--"))
  "List of buffer cleanup patterns.

The idea here is to replace characters that the tts cannot properly speak by an ASCII equivalent.
Use this only to replace things that occur rarely, otherwise,
rendering will become very slow."
  :group 'emacspeak-firemacs
  :type '(alist :key-type string :value-type string))

(defun emacspeak-fm-cleanup-add-character (char replacement)
  (interactive
   (let* ((c (char-after))
		  (s  (string c)))
				 (list s (read-string (format "Replace character code %d with: " c)))))
     (ensure-major-mode 'firemacs-mode)

  (let ((cell (assoc char emacspeak-fm-cleanup-alist)))
	(if cell
		(setcdr cell replacement)
	  (push (cons char replacement) emacspeak-fm-cleanup-alist))))

(defun emacspeak-fm-cleanup-region (start end)
  (interactive "r")
  (ensure-major-mode 'firemacs-mode)
  (let ((inhibit-read-only t))
	(save-excursion 
	  (loop for (char . replacement) in  emacspeak-fm-cleanup-alist do
			(goto-char start)
			(while (search-forward char end t)
			  (replace-match replacement t))))))

;;}}}
;;{{{ Voice setup

(voice-setup-add-map
 '(
   (firemacs-link-face voice-bolden-medium)
 (firemacs-heading-face  voice-lighten)
 ))

;;}}}
;;{{{Variables

(defconst emacspeak-fm-role-name-alist
  '(
	(fm-role-link . "link")
	(fm-role-link-visited "visited link")
	(fm-role-link-unvisited . "unvisited link")
	(fm-role-link-internal . "internal link")
	(fm-role-heading . "heading")
	(fm-role-image . "image")
	(fm-role-pushbutton . "button")
	(fm-role-entry . "edit")
	(fm-role-password . "password edit")
	(fm-role-checkbox . "checkbox")
	(fm-role-radiobutton . "radioButton")
	(fm-role-combobox . "comboBox")
	(fm-role-textarea . "textArea")
	)
  "Mapping form roles to their spoken reperesentation.")

(defvar emacspeak-fm-default-speak-spec '(content))

(defcustom emacspeak-fm-short-speak-spec-alist
  '(
	(fm-role-pushbutton . (role label))
	(fm-role-checkbox . (role state))
	(fm-role-radiobutton . (role state))
	(fm-role-entry . (role value))
	(fm-role-password . (role value))
	(fm-role-combobox . (role value state))
	(fm-role-link . ((fun emacspeak-fm-speak-link-attributes) role content))
	(fm-role-heading . (role (fun emacspeak-fm-speak-heading-level)content))
	(fm-role-listitem . ("bullet" content))
	(fm-role-image . (role content))
	)
  "Describe how nodes of different roles are spoken.

Maps roles to a list of spoken fields. Fields can be strings or one of the follwoing symbols:
content: Prolog, child nodes, epilog
role: The fole name of this node
label: A label for  this node if available
value: node value, mostly for controls like text entries and combo boxes
state: Node state, for checkboxes and radiobuttons")

(defcustom emacspeak-fm-long-speak-spec-alist
  '(
	(fm-role-pushbutton . (label role))
	(fm-role-entry . (label value role))
	(fm-role-password . (label value role))
	(fm-role-checkbox . (label role state))
	(fm-role-radiobutton . (label role state))
	(fm-role-combobox . (value role label state))
	(fm-role-link . (content (fun emacspeak-fm-speak-link-attributes)role))
	(fm-role-heading . (content role (fun emacspeak-fm-speak-heading-level)))
	(fm-role-listitem . ("bullet" content))
	)
  "Describes how nodes of different roles are spoken.

Long form is used when jumping to nodes directly.")

;;}}}
;;{{{Speaking complex junks of text

(defvar emacspeak-fm-speak-buffer nil
  "This is an auxiliary variable for emacspeak-fm-speak-part and emacspeak-fm-speak-complex.")

(defsubst emacspeak-fm-speak-part (s)
  "Queue S for later speaking."
  (setq emacspeak-fm-speak-buffer (cons s emacspeak-fm-speak-buffer)))

(defmacro emacspeak-fm-speak-complex (&rest body)
  "This is just a temporary hack.

It redefines emacspeak-fm-speak for BODY ins such a way that it only appends the string to be spoken to a buffer.
The purpose of this is to get more continues speech. this macro can be called recursively."
  `(let ((utterences
		  (let ((emacspeak-fm-speak-buffer (list "")))
			(flet ((emacspeak-fm-speak (s) (emacspeak-fm-speak-part s)))
			  ,@body
			  emacspeak-fm-speak-buffer))))
	 (if emacspeak-fm-speak-buffer
		 ;; This is a recursive call
		 (setq emacspeak-fm-speak-buffer (append utterences emacspeak-fm-speak-buffer))
	   ;; this is the outer most call
	   (dtk-speak (mapconcat 'identity (nreverse utterences) " "))
	   ;(dtk-speak-list (nreverse utterences))
	   )))

;;}}}

;;{{{Queries

(defsubst emacspeak-fm-node-role-name (node)
  (or
   (cdr-safe
	(assq
	 (firemacs-node-role node)
	 emacspeak-fm-role-name-alist))
   ""))

(defun firemacs-sort-nodes-by-priority (nodes)
  (sort* nodes '< :key (lambda (n) (firemacs-node-get-property n 'priority))))

;;}}}
;;{{{Speaking node properties

(defun emacspeak-fm-speak-node-role (node)
  (emacspeak-fm-speak (emacspeak-fm-node-role-name node)))

(defsubst firemacs-node-get-field (node field-name)
  (or (firemacs-node-get-property node field-name) ""))

(defun emacspeak-fm-speak-node-label (node)
  (emacspeak-fm-speak (firemacs-node-get-field node 'fm-label)))

(defun emacspeak-fm-speak-node-state (node)
  (emacspeak-fm-speak (firemacs-node-get-field node 'fm-state)))

(defun emacspeak-fm-speak-node-value (node)
  (emacspeak-fm-speak (firemacs-node-get-field node 'fm-value)))

(defun emacspeak-fm-speak-link-attributes  (node)
  (let ((visited (firemacs-node-get-property node 'fm-link-visited)))
	(when visited
	  (emacspeak-fm-speak "visited"))))

(defun emacspeak-fm-speak-heading-level (node)
  (let ((level (firemacs-node-get-property node 'fm-heading-level)))
	(when level
	  (emacspeak-fm-speak (format "level %d" level)))))
	   
  

(defun emacspeak-fm-speak-node-content (node &optional start-limit end-limit)
  (unless start-limit
	(setq start-limit (point-min)))
  (unless end-limit
	(setq end-limit (point-max)))
  (let ((children (firemacs-child-nodes node))
		(start (max start-limit (firemacs-node-start-pos node)))
		(end (min end-limit (firemacs-node-end-pos node))))
	(if children
		(let ((first-child-start (min end-limit (firemacs-node-start-pos (car children))))
			  (last-child-end (max start-limit (firemacs-node-end-pos (car (last children))))))
		  (when (> first-child-start start)
			(emacspeak-fm-speak (buffer-substring start first-child-start)))
		  (loop for child in children
				while (> end-limit (firemacs-node-start-pos child))
				do
				(when (> (firemacs-node-end-pos child) start-limit)
				  (emacspeak-fm-speak-node child start-limit end-limit)))
		  (when (> end last-child-end)
			(emacspeak-fm-speak (buffer-substring  last-child-end end))))
	  (emacspeak-fm-speak (buffer-substring start end)))))

;;}}}
;;{{{Speaking parts of the vuffer

(defun emacspeak-fm-speak (string)
  "This is merely a level of indirection, so we can easyly change the way we speak."
  (dtk-speak string))

(defun emacspeak-fm-speak-sentence (&optional arg)
  "Speak current sentence.
With prefix ARG, speaks the rest of the sentence  from point.
Negative prefix arg speaks from start of sentence to point."
  (interactive "P" )
  (when (listp arg) (setq arg (car arg )))
  (save-excursion
    (let ((orig (point))
          (inhibit-point-motion-hooks t)
          (start nil)
          (end nil))
      (forward-sentence 1)
      (setq end (point))
      (backward-sentence 1)
      (setq start (point))
      (emacspeak-handle-action-at-point)
      (cond
       ((null arg ))
       ((> arg 0) (setq start orig))
       ((< arg 0) (setq end orig )))
      (emacspeak-fm-speak-region  start end ))))


(defun emacspeak-fm-speak-line ()
  "Speak the current line, triggering all actions."
  (interactive)
  (let ((line (buffer-substring (line-beginning-position) (line-end-position))))
	(cond
	 ((string-equal "" line)
	  (dtk-stop)
	  (dtk-tone 250   75 'force))
	 (t 
	  (emacspeak-fm-speak-region (line-beginning-position) (line-end-position))))))
	
(defun emacspeak-fm-speak-region (start end)
  "Speak the text between START and END.

Normally speaks much additional information not present in the buffer."
  (interactive "r")
  (let ((start-node (firemacs-buffer-node-at start))
		(end-node (firemacs-buffer-node-at end)))
	(let ((common-ancestry
		   (nreverse (firemacs-sort-nodes-by-priority (intersection
													   (firemacs-node-lineage start-node)
													   (firemacs-node-lineage end-node))))))
	  (while (and (second common-ancestry)
				  (= start (firemacs-node-start-pos (second common-ancestry))))
		(setq common-ancestry (cdr common-ancestry)))
	  (emacspeak-fm-speak-complex
	   (emacspeak-fm-speak-node (car common-ancestry) start end)))))
						   
(defun emacspeak-fm-speak-node (node &optional start-limit end-limit)
  "Speak contents of node and all its child nodes."
  (unless start-limit
	(setq start-limit (point-min)))
  (unless end-limit
	(setq end-limit (point-max)))
  (let ((role (firemacs-node-role node))
		(start (firemacs-node-start-pos node))
		(end (firemacs-node-end-pos node)))
	(if (>= start start-limit)
		(let ((speak-spec
		   (if role
			   (or (cdr-safe (assq role emacspeak-fm-short-speak-spec-alist)) emacspeak-fm-default-speak-spec)
			 emacspeak-fm-default-speak-spec)))
		  (dolist (part speak-spec)
			(cond
			 ((stringp part) (emacspeak-fm-speak part))
			 ((and (listp part) (eq (car part) 'fun))
			  (apply (cadr part) node (cddr part)))
			 ((symbolp part)
			  (case part
				(role (emacspeak-fm-speak-node-role node))
				(label (emacspeak-fm-speak-node-label node))
				(state (emacspeak-fm-speak-node-state node))
				(value (emacspeak-fm-speak-node-value node))
				(content (emacspeak-fm-speak-node-content node start-limit end-limit)))))))
	  (emacspeak-fm-speak-node-content node start-limit end-limit))))

;;}}}
;;{{{User commands

(defadvice firemacs-move-to-table-cell (around emacspeak pre act)
  ad-do-it
  (let ((cell-info (ad-get-arg 0)))
	(emacspeak-fm-speak-cell-content)))

(defun emacspeak-fm-speak-cell-content ()
  (interactive)
  (ensure-major-mode 'firemacs-mode)
  (let ((node (firemacs-find-role-in-lineage (firemacs-buffer-node-at (point)) '(fm-role-cell))))
	(if (null node)
		(message "Not in a table cell.")
	  (emacspeak-fm-speak-complex
	   (emacspeak-fm-speak-cell-headings)
	   (emacspeak-fm-speak-node node)))))

(defun emacspeak-fm-speak-cell-headings (&optional info)
  (interactive)
  (ensure-major-mode 'firemacs-mode)
  (unless info
	(let ((node (firemacs-find-role-in-lineage (firemacs-buffer-node-at (point)) '(fm-role-cell))))
	  (if node
		  (setq info (mozremote-object-call-method-sync firemacs-remote-browser "getTableCellInfo" (firemacs-ref-for-node node)))
		(error "Not in a table cell"))))
  (mozremote-dictionary-with info
						 (row column rows columns level rowDesc colDesc rowSpan colSpan)
						 (emacspeak-fm-speak-complex
						  (when rowDesc
							(emacspeak-fm-speak-node (firemacs-node-for-ref rowDesc)))
						  (when colDesc
								(emacspeak-fm-speak-node (firemacs-node-for-ref colDesc))))))
							

(defun emacspeak-fm-speak-cell-info (&optional info)
  (interactive)
  (ensure-major-mode 'firemacs-mode)
  (unless info
	(let ((node (firemacs-find-role-in-lineage (firemacs-buffer-node-at (point)) '(fm-role-cell))))
	  (if node
		  (setq info (mozremote-object-call-method-sync firemacs-remote-browser "getTableCellInfo" (firemacs-ref-for-node node)))
		(error "Not in a table cell"))))
  
  (mozremote-dictionary-with info
						 (row column rows columns level rowDesc colDesc rowSpan colSpan)
						 (emacspeak-fm-speak (format "Row %d column %d in a %d by %d table %s. %s %s %s %s"
													 (1+ row) (1+ column) rows columns
													 (if (> level 0) (format "at nesting level %d" level) "")
													 (if (or rowSpan colSpan) " Cell spans " "")
													 (if rowSpan (format "%d rows" rowSpan) "")
													 (if (and rowSpan colSpan) "and" "")
													 (if colSpan (format "%d columns" colSpan) "")))))


;;}}}
;;{{{Advice definitions

(defadvice firemacs-next-line (after emacspeak pre act)
  "Speak line we just moved to."
  (when (interactive-p)
	(emacspeak-fm-speak-line)))

(defadvice firemacs-previous-line (after emacspeak pre act)
  "Speak line we just moved to."
  (when (interactive-p)
	(emacspeak-fm-speak-line)))

(defadvice firemacs-forward-sentence (after emacspeak pre act)
  "Speak  sentence  after moving."
  (when (interactive-p)
	(emacspeak-fm-speak-sentence    )))

(defadvice firemacs-backward-sentence (after emacspeak pre act)
  "Speak  sentence  after moving."
  (when (interactive-p)
	(emacspeak-fm-speak-sentence    )))


;;{{{Auto generate advice for firemacs-nex-XXX and firemacs-previous-XXX commands

(defun emacspeak-fm-speak-target-node (interactive-p target-node)
  (cond
   ((and interactive-p target-node)
	(emacspeak-auditory-icon 'large-movement)
	(let ((emacspeak-fm-short-speak-spec-alist emacspeak-fm-long-speak-spec-alist))
	  (emacspeak-fm-speak-complex
	   (emacspeak-fm-speak-node target-node nil (
												 min
												 (firemacs-node-end-pos target-node)
												 (line-end-position))))))
   (interactive-p
	(message "No more targets."))))

(defmacro emacspeak-fm-advice-jump-command (command)
  `(defadvice ,command (after emacspeak pre act)
	 "Speak page element we just jumped to."
	(emacspeak-fm-speak-target-node (interactive-p) ad-return-value)))

(defmacro emacspeak-fm-advice-jump-commands-from-spec (spec)
  `(progn 
	 ,@(loop for name in (mapcar 'car (eval spec))
			 collect `(emacspeak-fm-advice-jump-command ,(intern (concat "firemacs-previous-" name)))
			 collect `(emacspeak-fm-advice-jump-command ,(intern (concat "firemacs-next-" name))))))
  
(emacspeak-fm-advice-jump-commands-from-spec firemacs-jump-command-list)
(emacspeak-fm-advice-jump-command firemacs-next-heading)
(emacspeak-fm-advice-jump-command firemacs-previous-heading)

;;}}}

;;}}}
;;{{{Setup hooks

(defun emacspeak-fm-rendering-done ()
  (when emacspeak-fm-cleanup-nonascii-characters
	(emacspeak-fm-cleanup-region (point-min) (point-max)))
  (emacspeak-auditory-icon 'open-object))

(add-hook 'firemacs-rendering-done-hook 'emacspeak-fm-rendering-done)

;;}}}
;;{{{Set up key map

(defun emacspeak-fm-mode-hook ()
  "Setup emacspeak specific keys."
  (local-set-key "\C-el" 'emacspeak-fm-speak-line)
  (local-set-key "." 'emacspeak-fm-speak-cell-content)
  (local-set-key "=" 'emacspeak-fm-speak-cell-info)
  (local-set-key "," 'emacspeak-fm-speak-cell-headings))


(add-hook 'firemacs-mode-hook 'emacspeak-fm-mode-hook)

;;}}}

;;{{{  emacs local variables

;;; local variables:
;;; folded-file: t
;;; byte-compile-dynamic: t
;;; end:

;;}}}

;;; emacspeak-firemacs.el ends here
